BBS in a Box 7/BBS in a Box - Macintosh - Volume VII (BBS in a Box) (January 1993).iso/Files/Hyper/S-Sh/ScrollControl.cpt/ScrollControl XCMD/card_7628.txt

Text File | 1989-04-22 | 6KB | 256 lines

-- card: 7628 from stack: in
-- bmap block id: 0
-- flags: 0000
-- background id: 7195
-- name:


-- part contents for background part 3
----- text -----
For those of you interested here is the source code listing for the ScrollControl XCMD done in Think Pascal‚Ñ¢. It was compiled and linked with the DRVRRuntime library. Then it was built and saved as a resource of type XCMD and pasted along via ResEdit into this stack.



-- part contents for background part 2
----- text -----
unit ScrollBarForHypercard;
interface
 type
  XCmdPtr = ^XCmdBlock;
  XCmdBlock = record
    paramCount: INTEGER;
    params: array[1..16] of Handle;
    returnValue: Handle;
    passFlag: BOOLEAN;

    entryPoint: ProcPtr;
    request: INTEGER;
    result: INTEGER;
    inArgs: array[1..8] of LongInt;
    outArgs: array[1..4] of LongInt;
   end;

 procedure main (paramPtr: XCmdPtr);

implementation
 procedure ScrollControl (paramPtr: XCmdPtr);
 forward;

 procedure main;
 begin
  ScrollControl(paramPtr);
 end;

 procedure ScrollText (theControl: Controlhandle; thePart: integer);
  var
   oldvalue, delta: integer;
 begin
  if thePart <> 0 then
   begin
    oldValue := GetCtlValue(theControl);
   end;
  case thePart of
   inUpButton:
    delta := -1;
   inDownButton:
    delta := +1;
   inPageUp:
    delta := -2;
   inPageDown:
    delta := +2;
   otherwise
  end;
  if thePart <> 0 then
   SetCtlValue(theControl, oldValue + delta);
 end;

 procedure ScrollControl;
  const
   xreqSendCardMessage = 1;
   xreqEvalExpr = 2;
   xreqPasToZero = 7;
   xreqZeroToPas = 8;
   xreqStrToNum = 10;
   xreqStrToBool = 11;
   xreqNumToStr = 14;
  type
   Str31 = string[31];
  var
   resultString: Str31;
   theString: Str255;
   whichWindow: WindowPtr;
   myEvent: EventRecord;
   box, ButtonRect: rect;
   theBar: ControlHandle;
   done, horizontal: boolean;
   theControl: ControlHandle;
   thePoint: Point;
   thePart, oldValue, delta, NewCtlValue, CtlInitValue, CtlMinValue, CtlMaxValue: integer;


  procedure DoJsr (addr: ProcPtr);
  inline
   $205F, $4E90;

  procedure ZeroToPas (zeroStr: Ptr; var pasStr: Str255);
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(zeroStr);
     inArgs[2] := ORD(@pasStr);
     request := xreqZeroToPas;
     DoJsr(entryPoint);
    end;
  end;

  function EvalExpr (expr: Str255): Handle;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@expr);
     request := xreqEvalExpr;
     DoJsr(entryPoint);
     EvalExpr := Handle(outArgs[1]);
    end;
  end;

  function StrToNum (str: Str31): LongInt;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@str);
     request := xreqStrToNum;
     DoJsr(entryPoint);
     StrToNum := outArgs[1];
    end;
  end;

  function NumToStr (num: LongInt): Str31;
   var
    str: Str31;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := num;
     inArgs[2] := ORD(@str);
     request := xreqNumToStr;
     DoJsr(entryPoint);
     NumToStr := str;
    end;
  end;

  procedure SendCardMessage (msg: Str255);
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@msg);
     request := xreqSendCardMessage;
     DoJsr(entryPoint);
    end;
  end;

  function IntExpr (theString: str255): integer;
   type
    Ptr31 = ^str31;
    Hand31 = ^Ptr31;
   var
    tempHand: handle;
    ShortStr: str31;
    NumLong: longint;
    LongStr: str255;
  begin
   tempHand := EvalExpr(theString);
   ZeroToPas(tempHand^, LongStr);
   ShortStr := LongStr;
   NumLong := StrToNum(ShortStr);
   IntExpr := loword(NumLong);
  end;

  procedure DoScroll (thePart: integer; thePoint: point);
  begin
   if thePart = InThumb then
    begin
     thePart := TrackControl(theBar, thePoint, nil);
    end
   else
    begin
     thePart := TrackControl(theBar, thePoint, @ScrollText);
    end;
   NewCtlValue := GetCtlValue(theControl);
   resultString := NumToStr(NewCtlValue);
   theString := concat('put ', resultString, ' into curCtlValue');
   SendCardMessage(theString);
  end;

  procedure doContent (whichWindow: windowPtr; thePoint: Point);
   var
    thePart: integer;
  begin
   GlobalToLocal(thePoint);
   thePart := FindControl(thePoint, whichWindow, theControl);
   DoScroll(thePart, thePoint)
  end;

  procedure DrawScroll;
   var
    btnName: Str255;
  begin
   ButtonRect.left := IntExpr(concat('item 1 of the rect of the target'));
   ButtonRect.top := IntExpr(concat('item 2 of the rect of the target'));
   ButtonRect.right := IntExpr(concat('item 3 of the rect of  the target'));
   ButtonRect.bottom := IntExpr(concat('item 4 of the rect of the target'));
   setRect(box, ButtonRect.left, ButtonRect.top, ButtonRect.right, ButtonRect.bottom);
   getPort(whichWindow);
   setPort(whichWindow);
   with ParamPtr^ do
    begin
     ZeroToPas(params[1]^, theString);
     CtlMinValue := StrToNum(theString);
     ZeroToPas(params[2]^, theString);
     CtlMaxValue := StrToNum(theString);
     ZeroToPas(params[3]^, theString);
     CtlInitValue := StrToNum(theString);
    end;
   theBar := NewControl(whichWindow, box, '', true, 0, 0, 0, 16, 0);
   SetCtlMax(theBar, CtlMaxValue);
   SetCtlMin(theBar, CtlMinValue);
   SetCtlValue(theBar, CtlInitValue);
  end;

  procedure XCMDOff;
  begin
   DisposeControl(theBar);
   done := true;
  end;

 begin
  done := false;
  DrawScroll;
  repeat
   begin
    GetMouse(thePoint);
    if PtInRect(thePoint, box) then
     begin
     if GetNextEvent(everyEvent, myEvent) then
     begin
     case myEvent.what of
     mouseDown:
     begin
     if FindWindow(myEvent.where, whichWindow) = inContent then
     begin
     DoContent(whichWindow, myEvent.where);
     end
     else
     XCMDOff;
     end;
     otherwise
     end;
     end;
     end
    else
     XCMDOff;
   end;
  until done;
 end;
end.